home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / scamacr.scm < prev    next >
Encoding:
Text File  |  1994-05-25  |  6.1 KB  |  170 lines
  1. ;;; "scamacr.scm" syntax-case macros for Scheme constructs
  2. ;;; Written by Robert Hieb & Kent Dybvig
  3.  
  4. ;;; This file was munged by a simple minded sed script since it left
  5. ;;; its original authors' hands.  See syncase.sh for the horrid details.
  6.  
  7. ;;; macro-defs.ss
  8. ;;; Robert Hieb & Kent Dybvig
  9. ;;; 92/06/18
  10.  
  11. (define-syntax with-syntax
  12.    (lambda (x)
  13.       (syntax-case x ()
  14.          ((_ () e1 e2 ...)
  15.           (syntax (begin e1 e2 ...)))
  16.          ((_ ((out in)) e1 e2 ...)
  17.           (syntax (syntax-case in () (out (begin e1 e2 ...)))))
  18.          ((_ ((out in) ...) e1 e2 ...)
  19.           (syntax (syntax-case (list in ...) ()
  20.                      ((out ...) (begin e1 e2 ...))))))))
  21.  
  22. (define-syntax syntax-rules
  23.    (lambda (x)
  24.       (syntax-case x ()
  25.          ((_ (k ...) ((keyword . pattern) template) ...)
  26.           (with-syntax (((dummy ...)
  27.                          (generate-temporaries (syntax (keyword ...)))))
  28.              (syntax (lambda (x)
  29.                         (syntax-case x (k ...)
  30.                            ((dummy . pattern) (syntax template))
  31.                            ...))))))))
  32.  
  33. (define-syntax or
  34.    (lambda (x)
  35.       (syntax-case x ()
  36.          ((_) (syntax #f))
  37.          ((_ e) (syntax e))
  38.          ((_ e1 e2 e3 ...)
  39.           (syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
  40.  
  41. (define-syntax and
  42.    (lambda (x)
  43.       (syntax-case x ()
  44.          ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
  45.          ((_ e) (syntax e))
  46.          ((_) (syntax #t)))))
  47.  
  48. (define-syntax cond
  49.    (lambda (x)
  50.       (syntax-case x (else =>)
  51.          ((_ (else e1 e2 ...))
  52.           (syntax (begin e1 e2 ...)))
  53.          ((_ (e0))
  54.           (syntax (let ((t e0)) (if t t))))
  55.          ((_ (e0) c1 c2 ...)
  56.           (syntax (let ((t e0)) (if t t (cond c1 c2 ...)))))
  57.          ((_ (e0 => e1)) (syntax (let ((t e0)) (if t (e1 t)))))
  58.          ((_ (e0 => e1) c1 c2 ...)
  59.           (syntax (let ((t e0)) (if t (e1 t) (cond c1 c2 ...)))))
  60.          ((_ (e0 e1 e2 ...)) (syntax (if e0 (begin e1 e2 ...))))
  61.          ((_ (e0 e1 e2 ...) c1 c2 ...)
  62.           (syntax (if e0 (begin e1 e2 ...) (cond c1 c2 ...)))))))
  63.  
  64. (define-syntax let*
  65.    (lambda (x)
  66.       (syntax-case x ()
  67.          ((let* () e1 e2 ...)
  68.           (syntax (let () e1 e2 ...)))
  69.          ((let* ((x1 v1) (x2 v2) ...) e1 e2 ...)
  70.           (comlist:every identifier? (syntax (x1 x2 ...)))
  71.           (syntax (let ((x1 v1)) (let* ((x2 v2) ...) e1 e2 ...)))))))
  72.  
  73. (define-syntax case
  74.    (lambda (x)
  75.       (syntax-case x (else)
  76.          ((_ v (else e1 e2 ...))
  77.           (syntax (begin v e1 e2 ...)))
  78.          ((_ v ((k ...) e1 e2 ...))
  79.           (syntax (if (memv v '(k ...)) (begin e1 e2 ...))))
  80.          ((_ v ((k ...) e1 e2 ...) c1 c2 ...)
  81.           (syntax (let ((x v))
  82.                      (if (memv x '(k ...))
  83.                          (begin e1 e2 ...)
  84.                          (case x c1 c2 ...))))))))
  85.  
  86. (define-syntax do
  87.    (lambda (orig-x)
  88.       (syntax-case orig-x ()
  89.          ((_ ((var init . step) ...) (e0 e1 ...) c ...)
  90.           (with-syntax (((step ...)
  91.                          (map (lambda (v s)
  92.                                  (syntax-case s ()
  93.                                     (() v)
  94.                                     ((e) (syntax e))
  95.                                     (_ (syntax-error orig-x))))
  96.                               (syntax (var ...))
  97.                               (syntax (step ...)))))
  98.              (syntax-case (syntax (e1 ...)) ()
  99.                 (() (syntax (let doloop ((var init) ...)
  100.                                (if (not e0)
  101.                                    (begin c ... (doloop step ...))))))
  102.                 ((e1 e2 ...)
  103.                  (syntax (let doloop ((var init) ...)
  104.                             (if e0
  105.                                 (begin e1 e2 ...)
  106.                                 (begin c ... (doloop step ...))))))))))))
  107.  
  108. (define-syntax quasiquote
  109.    (letrec
  110.       ((gen-cons
  111.         (lambda (x y)
  112.            (syntax-case x (quote)
  113.               ((quote x)
  114.                (syntax-case y (quote list)
  115.                   ((quote y) (syntax (quote (x . y))))
  116.                   ((list y ...) (syntax (list (quote x) y ...)))
  117.                   (y (syntax (cons (quote x) y)))))
  118.               (x (syntax-case y (quote list)
  119.                    ((quote ()) (syntax (list x)))
  120.                    ((list y ...) (syntax (list x y ...)))
  121.                    (y (syntax (cons x y))))))))
  122.  
  123.        (gen-append
  124.         (lambda (x y)
  125.            (syntax-case x (quote list cons)
  126.               ((quote (x1 x2 ...))
  127.                (syntax-case y (quote)
  128.                   ((quote y) (syntax (quote (x1 x2 ... . y))))
  129.                   (y (syntax (append (quote (x1 x2 ...) y))))))
  130.               ((quote ()) y)
  131.               ((list x1 x2 ...)
  132.                (gen-cons (syntax x1) (gen-append (syntax (list x2 ...)) y)))
  133.               (x (syntax-case y (quote list)
  134.                    ((quote ()) (syntax x))
  135.                    (y (syntax (append x y))))))))
  136.  
  137.        (gen-vector
  138.         (lambda (x)
  139.            (syntax-case x (quote list)
  140.               ((quote (x ...)) (syntax (quote #(x ...))))
  141.               ((list x ...) (syntax (vector x ...)))
  142.               (x (syntax (list->vector x))))))
  143.  
  144.        (gen
  145.         (lambda (p lev)
  146.            (syntax-case p (unquote unquote-splicing quasiquote)
  147.               ((unquote p)
  148.                (if (= lev 0)
  149.                    (syntax p)
  150.                    (gen-cons (syntax (quote unquote))
  151.                              (gen (syntax (p)) (- lev 1)))))
  152.               (((unquote-splicing p) . q)
  153.                (if (= lev 0)
  154.                    (gen-append (syntax p) (gen (syntax q) lev))
  155.                    (gen-cons (gen-cons (syntax (quote unquote-splicing))
  156.                                        (gen (syntax p) (- lev 1)))
  157.                              (gen (syntax q) lev))))
  158.               ((quasiquote p)
  159.                (gen-cons (syntax (quote quasiquote))
  160.                          (gen (syntax (p)) (+ lev 1))))
  161.               ((p . q)
  162.                (gen-cons (gen (syntax p) lev) (gen (syntax q) lev)))
  163.               (#(x ...) (gen-vector (gen (syntax (x ...)) lev)))
  164.               (p (syntax (quote p)))))))
  165.  
  166.     (lambda (x)
  167.        (syntax-case x ()
  168.           ((- e) (gen (syntax e) 0))))))
  169.  
  170.